home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Fritz: All Fritz
/
All Fritz.zip
/
All Fritz
/
FILES
/
PROGMISC
/
FPCDOCS.LZH
/
SEQREAD.SEQ
< prev
next >
Wrap
Text File
|
1988-09-28
|
17KB
|
427 lines
\ SEQREAD.SEQ Sequential read and load file by Tom Zimmer
\ Link this file into the FILELIST chain.
FILES DEFINITIONS
VARIABLE SEQREAD.SEQ
FORTH DEFINITIONS
DECIMAL
\ Read sequential lines from a file, delimited by CRLF.
0 VALUE WITHPATH \ should the PATH be included in the file var
16384 VALUE IBLEN \ input buffer length
\ A couple of editor words, needed to give the information editor when
\ a compile error has occured.
0 VALUE BYTE|LINE
0 VALUE SCREENCHAR
\ The value of OBLEN can be reduced to 64 if you want to read lines from
\ normal Forth BLOCK files. You should use BLKTOSEQ.SEQ for this though.
255 VALUE OBLEN \ output buffer length
0 VALUE INSTART
0 VALUE INLENGTH
0 VALUE INBSEG \ the input buffer
VARIABLE LISTOFF
VARIABLE TOTALLINES
CREATE OUTBUF OBLEN 1+ ALLOT \ the line output buffer
4 B/HCB * CONSTANT MAXNEST \ maximum of 5 hcb's
CREATE HNDLS MAXNEST B/HCB + ALLOT
HNDLS ' SEQHANDLE >BODY !-T \ PRESET POINTER
VARIABLE FILEPOINTER 2 allot \ most recent read
VARIABLE LOADING \ Are we in the proccess of loading a file?
0 LOADING !-T \ initialize to not loading.
CREATE CONHNDL B/HCB ALLOT 1 CONHNDL >HNDLE !-T
CREATE PRNHNDL B/HCB ALLOT 4 PRNHNDL >HNDLE !-T
: (CONSOLE) ( C1 --- )
OUTPAUSE
SP@ 1 CONHNDL TYPESEG @ EXHWRITE 2DROP
#OUT INCR ;
: (TYPE) ( A1 N1 --- )
OUTPAUSE 0 MAX
PRINTING @
IF 2DUP PRNHNDL TYPESEG @ EXHWRITE DROP
THEN CONHNDL TYPESEG @ EXHWRITE #OUT +! ;
: (PRINT) ( C1 --- )
OUTPAUSE
SP@ 1 PRNHNDL TYPESEG @ EXHWRITE 2DROP
#OUT INCR ;
: (EXTYPE) ( SEG A1 N1 --- ) \ External type, from other segment
ROT %SAVE!> TYPESEG
TYPE
%RESTORE> TYPESEG ;
DEFER LOADSTAT ' NOOP IS LOADSTAT
: SEQHANDLE+ ( --- A1 )
seqhandle b/hcb + ;
: .SEQHANDLE ( --- )
seqhandle count type ;
CODE CURPOINTER ( handle --- double-current )
pop bx
add bx, # hndloffset
mov bx, 0 [bx]
sub cx, cx
mov dx, cx
mov ax, # $4201 \ from end of file
int $21
push ax
push dx
next
end-code
: SAVEPOINTER ( --- )
seqhandle curpointer inlength 0 d- filepointer 2! ;
CODE GET_ALINE ( --- a1 )
push es \ Save ES for later restoral
mov di, ' instart >body \ Searching from INSTART
mov ax, # $0A \ Searching for a Linefeed char
mov cx, ' inlength >body \ for INLENGTH clipped to OBLEN
cmp cx, ' oblen >body \ if INLENGTH > OBLEN
> if mov cx, ' oblen >body \ clip search length to OBLEN
then mov dx, cx \ save search length in DX
cx<>0 if mov es, ' inbseg >body \ searching INBSEG segment
repnz scasb \ Scan for Linefeed char
then sub dx, cx \ DX = length of line
sub ' inlength >body dx \ subtract line from remaining
mov outbuf dl byte \ set the length of OUTBUF
mov bx, si \ save IP for later restoral
mov si, ' instart >body \ moving from INSTART
add ' instart >body dx \ set start to after line
mov cx, dx \ cx = length to move
mov di, # outbuf 1+ \ moving to OUTBUF
mov ds, ' inbseg >body \ from INBSEG segment
mov ax, cs mov es, ax \ to CODE segment
cx<>0 if repnz movsb \ move the line to OUTBUF
then
mov ax, cs mov ds, ax \ restore DS
mov si, bx \ restore IP
inc errorline word \ bump line counter
pop es \ restore ES
mov ax, # outbuf \ return address of buffer
1push end-code
: FILLBUFF ( --- ) \ Refill the input buffer.
inbseg instart over 0 inlength cmovel
off> instart
inlength iblen inlength -
seqhandle inbseg exhread +!> inlength
savepointer ;
CODE ?FILLBUFF ( --- ) \ refill INBUF if needed
cmp ' inlength >body # oblen 1+ word
u>= if mov bx, # filepointer \ Set BX to point to FILEPOINTER
sub cx, cx \ clear CX
mov cl, outbuf \ read byte length of OUTBUF
add 2 [bx], cx \ Add to 32bit contents
adc 0 [bx], # 0
next
then \ If we got here, then
mov ax, # ' fillbuff \ go and re-fill the buffer
jmp ax
end-code
: LINEREAD ( --- a1 ) \ read a line delimited by CRLF
?fillbuff \ re-fill buffer if needed.
get_aline ; \ returns line including CRLF
: (DOERROR) ( a1 n1 --- )
2>r
cr ." file = " .seqhandle
." at Line " errorline @ u.
cr outbuf count type cr
>in @ 1- here c@ - 0 max
dup %!> screenchar 0
?do ascii - emit loop
." ^-- " 2r> type space
true %!> byte|line
quit ;
DEFER DOERROR ' (DOERROR) IS DOERROR
: (?SERROR) ( ADDR N1 BOOL --- )
%@> loading
if
if 2>R sp0 @ sp! printing off loading off
decimal
['] <run> is run
2R> doerror
quit \ error from disk
else 2drop \ no error comes here
then
else (?error) \ command line error
then ;
' (?SERROR) IS ?ERROR
: SEQUP ( --- )
seqhandle >hndle @ -1 >
if seqhandle b/hcb + dup hndls maxnest + U< 0=
abort" Nested too deeply on FLOAD !"
dup %!> seqhandle clr-hcb
then ;
: SEQINIT ( --- )
noop hndls %!> seqhandle
hndls maxnest over + swap
do i clr-hcb
b/hcb +loop
iblen 0 16 um/mod nip 1+ alloc 8 = memchk nip %!> inbseg
conhndl clr-hcb " CON." ">$ conhndl $>handle
1 conhndl >hndle !
prnhndl clr-hcb " PRN." ">$ prnhndl $>handle
4 prnhndl >hndle ! ;
: IBRESET ( --- )
off> instart
off> inlength ;
: SEQDOWN ( --- )
seqhandle hclose drop
seqhandle clr-hcb
seqhandle b/hcb - hndls max %!> seqhandle
seqhandle >hndle @ -1 <>
if filepointer 2@
seqhandle movepointer
off> >in off> span off> #tib
IBRESET
then ;
: CLOSE ( --- )
seqdown ;
: $HOPEN ( A1 --- F1 ) \ Returns a boolean for open successful
seqhandle hclose drop
seqhandle $>handle
seqhandle hopen
ibreset ;
DEFER GETFILE ( --- <a1> f1 ) \ return a1 filename addr and
' FALSE IS GETFILE \ Default to failed
: FILE>TIB ( a1 --- ) \ given a counted string a1, insert it
count \ 2dup type space \ into the Terminal Input Buffer.
2dup true -rot over + swap
do i c@ ascii . =
if drop false leave
then
loop >r dup span ! dup #tib ! >in off
tib swap cmove r>
if ascii . span @ tib + c!
span incr #tib incr
then ;
: GFL ( --- ) \ optionally prompt for file if non
\ is currently in the TIB.
>in @ span @ 1- >
if getfile 0= abort" No filename specified"
dup count type space
file>tib
then ;
: FILE ( --- )
gfl bl word $hopen abort" File open Error!"
." of " seqhandle endfile d. ." bytes."
0.0 seqhandle movepointer \ reset to beginning of file
errorline off \ reset last line variable
loadline off \ reset file offset
listoff off
0 %!> screenchar ;
: SEEK ( d1 --- ) \ Move the filepointer in seqhandle to the
seqhandle movepointer ; \ specified by d1.
0 VALUE LISTVAR
: SHOWLINES ( --- ) -1 %!> listvar ;
: HIDELINES ( --- ) 0 %!> listvar ;
CODE CRLF>BL'S ( a1 --- a1 ) \ change CRLF at end of string to blanks
pop bx \ leaving the string address on the stack
push bx \ Same as -> DUP COUNT + 2- 8224 SWAP !
mov al, 0 [bx]
sub ah, ah
add bx, ax
dec bx
mov 0 [bx], # 8224 word
next
end-code
CODE SETTIB ( a1 --- ) \ Set TIB to counted string a1
pop bx
mov al, 0 [bx]
inc bx
mov 'tib bx
sub ah, ah
mov span ax
mov #tib ax
mov >in # 0
next
end-code
: .LOADLINE ( a1 --- a1 )
cr errorline @ 5 u.r space
dup count type ;
CODE ?.LOADLINE ( a1 --- a1 )
mov cx, ' listvar >body
cx<>0 if mov ax, # ' .loadline \ if LISTVAR <> zero, continue
jmp ax
then \ if LISTVAR is zero then
next end-code
CODE LOADLINE+SPAN ( --- )
mov ax, span
add loadline ax
next
end-code
: FILLTIB ( --- )
loadline+span
lineread crlf>bl's ?.loadline settib ;
CODE ?.STAT ( --- )
test errorline # 255 \ only once every 256 lines
0= if mov ax, # ' loadstat \ loadstat is : def
jmp ax \ so we need to goto it this
then \ way. Can't just do a direct
next end-code \ JMP ' LOADSTAT
CODE LENGTH.CHECK ( --- F1 )
mov ax, # true
mov cx, ' inlength >body \ if read length <> 0
cx<>0 if 1push \ then we aren't done
then
pop ax \ get a copy of line buf ptr
push ax
mov bx, ax
cmp 0 [bx], # 0 byte \ if line buffer <> 0
0<> if 1push \ then we aren't done
then
mov ax, # false
1push end-code \ else we are done
: <LOAD> ( --- )
loadstat
true %save!> loading
%save> 'tib
%save> >in
false %save!> span
%save> errorline
0 %!> screenchar
begin loadline+span
lineread
length.check
while crlf>bl's ?.loadline settib run ?.stat
repeat drop
%@> errorline +!> totallines
%restore> errorline
%restore> span
%@> span %!> #tib
%restore> >in
%restore> 'tib
%restore> loading ;
DEFER LOADER ' <LOAD> IS LOADER
: >LINE ( n1 --- )
0.0 seqhandle movepointer
loadline off
IBRESET
errorline off
1- 0 max ?dup
if cr ." Stepping to line " dup 1+ u. ." .."
0
?do lineread c@ dup loadline +! 0= ?leave
loop
then ;
: LOADED, ( --- )
%save> 'tib
%save> >in
%save> span \ save state
seqhandle count
withpath 0= \ Should the PATH not be
if \ included in the file VARIABLE?
begin 2dup
ascii \ scan dup \ skip the leading path
while 2swap 2drop
1 -1 d+
repeat 2drop
then
dup %!> span %!> #tib \ set span and #tib
%!> 'tib \ set tib to seqhandle
off> >in \ clear >in
context @ >r \ save current context
current @ >r \ and current vocab state
files definitions \ select files vocabulary
variable \ make the header
r> current ! r> context ! \ restore vocabulary state
%restore> span
%@> span %!> #tib
%restore> >in
%restore> 'tib ;
: <FLOAD> ( --- )
span @ >r
0 %save!> loadline
0 %save!> errorline
loaded,
0.0 seqhandle movepointer
loader
%restore> errorline
%restore> loadline
r> +!> loadline ;
: FLOAD ( --- t1 )
sequp
IBRESET
%@> >in bl word c@ over %!> >in +
0 filepointer 2@ d+ 2>r
off> outbuf
seqhandle !hcb
seqhandle hopen 0<>
if cr ." Open error in " .seqhandle
abort
then <fload>
2r> filepointer 2!
seqdown ;
: CHARREAD ( --- c1 ) \ Read a character from the current file.
loading @
if begin %@> >in %@> span = \ If nothing in line
inlength 0> and \ and input buf not empty
while ?fillbuff \ Optionally refill buffer
filltib \ refill the TIB
repeat
then %@> >in incr> >in tib + c@ ;
: OK ( --- ) \ Load currently open file
IBRESET
<fload> ;
: \S ( n1 --- ) \ Ignore the rest of the file.
seqhandle endfile 2drop \ Move to end of file
loadline off
IBRESET
%@> span %!> >in ; \ Ignore rest of line